(* ===================================================================== *)
(** Outils pour maping scriptable des noms de variables pour affichage 
    @author Mathieu Barbin
    @date samedi 3 janvier 2009, 08:16:24 (UTC+0100) *)
(* ===================================================================== *)

(*
#load "unix.cma";;
#load "graphics.cma";;
#load "bplib.cma";;
*)

open MopTypes
open Bplib


(* A propos du parsing *)

let parse_of_file filename =
  try
    MopTypes.mop_line := 1;
    MopTypes.mop_file := filename;
    let ic = open_in filename in
    let buff = Lexing.from_channel ic in 
    let youpi = ParserMop.mop_ast LexerMop.lexem_list buff
    in
    begin
      close_in ic;
      prerr_endline (Printf.sprintf "parsing mop file \"%s\"" filename);
      Some youpi
    end
  with
  | Sys_error _ -> 
      begin
	prerr_endline (Printf.sprintf "[!] import mop defs \"%s\" : nu such file" filename);
	None
      end
  | Parsing.Parse_error ->
      begin
	prerr_endline (Printf.sprintf "[!] mop file \"%s\" line %d : Syntax Error (file ignored)" filename (!mop_line));
	None
      end
  | Failure m -> 
      begin
	prerr_endline (Printf.sprintf "[!] mop file \"%s\" ignored : %s" filename m);
	None
      end
;;


let multi_parse filename =
  let visited = ref [] in
  let rec aux accu filename =
    if List.mem filename !visited
    then accu
    else
      begin
	visited := filename::(!visited);
	match parse_of_file filename with
	| None -> accu
	| Some ast ->
	    let new_accu = concat_ast ast accu in
	    List.fold_left (fun ac (_, inc) -> aux ac inc) new_accu ast.includes
      end
  in aux ast_empty filename;;


(* Ensuite, implementation de l'analyse et maping *)

(* Il y a une redondance dans le type, puisque qu'un map_tree peut etre vide
   mais sinon la definition du type tag est cyclique *)

(** Ordre : Structure * etoile * suite du dictionnaire *)
type 'a map_struct = 'a option * 'a option * 'a map_tree
and 'a map_tree = Nil | Tree of 'a map_struct CharMap.t
  
let p_ident id = String.make id ' '

let repr_struct (repr_a:int -> 'a -> string) (t:'a map_struct) = 
  let rec repr_option ident = function
    | None -> "None"
    | Some a -> repr_a ident a
  and repr_stt ident = function
    | (opts, optet, tree) ->
	Printf.sprintf "(Struct (%s ) - Etoile (%s )\n%s%s)" (repr_option ident opts) (repr_option ident optet) (repr_tree (succ ident) tree)  (p_ident ident)
  and repr_tree ident = function
    | Nil -> ""
    | Tree t -> 
	let fold key map accu = Printf.sprintf "%s%s'%c' : %s\n" accu (p_ident ident) key (repr_stt (succ ident) map) in
	CharMap.fold fold t ""
  in repr_stt 0 t ;;  


(* On peut ajouter une variable dans la structure *)
(* On peut chercher a acceder aux infos pour maper *)
(* La structure une fois trouver le module, est une t StringMap.t *)

type string_pref = Complet | Prefixe 

let char_list_of_string s =
  let len = String.length s in
  let rec aux accu i =
    if i < 0 then accu
    else aux (s.[i]::accu) (pred i) 
  in aux [] (pred len);;

let string_pref_of_string s =
  let len = String.length s in
  if len > 1 
  then
    if s.[pred len] = '*'
    then Prefixe, String.sub s 0 (pred len)
    else Complet, s
  else Complet, s;;


module type MapItemType =  
sig
  type t

  (* Construire statiquement une map structure : 
     produit les warning et eventuellement ignore s'il faut *)
  val make : name:string -> matching_item list -> t

  val repr : int -> t -> string 
  (* une fois qu'on a trouvee la bonne structure, on cherche a maper *)
  val map : t -> bool array -> string
end 
  
module type MapStructType =
sig
  type item
  type t (* = item StringMap.t map_struct *)

  val repr : int -> t -> string

  val empty : t

  val make_item : name:string -> matching_item list -> item

  (* module avec l'etoile en fin, variable MapStruct MapTree  *)
  val add : string -> string -> item -> t -> t

  val map : t -> string -> string -> bool array -> string

  val of_ast : bopmop_ast -> t

  val of_file : string -> t
end


(* Implementation du MapStruct *)
exception Redefinition of string * string

module MapStructMake (Item : MapItemType) : MapStructType with type item = Item.t =
struct
  type item = Item.t
  type t = item StringMap.t map_struct

  let repr (ident:int) t = 
    let repr_a ident iSMap =
      let fold key item accu = Printf.sprintf "%s\n%s%s:\n%s" accu (p_ident ident) ("map "^key^" with") (Item.repr (succ ident) item) in
      StringMap.fold fold iSMap ""
    in repr_struct repr_a t

  let empty = None, None, Nil

  let make_item = Item.make

  let add modul var item tree =
    let pref, name = string_pref_of_string modul in
    let char_list = char_list_of_string name in
    let item_add var t st =
      if StringMap.mem var st
      then raise (Redefinition (modul, var))
      else StringMap.add var t st
    in
    let rec aux tree rest = 
      match tree with
      | (complet, etoile, fils) ->
	  begin
	    match rest with
	    | [] ->
		begin
		  (* On a tout lu, il faut ajouter ici *)
		  if pref = Prefixe (* alors on ajoute dans l'etoile sinon, dans struct *) 
		  then
		    match etoile with
		    | None -> (complet, Some (item_add var item StringMap.empty), fils)
		    | Some et -> 
			(* On cherche a ajouter une variable dans un module *)
			(* On a le droit de le faire sauf si elle y est deja *)
			let new_et = item_add var item et in
			(complet, Some new_et, fils)
		  else
		    match complet with 
		    | None -> (Some (item_add var item StringMap.empty), etoile, fils)
		    | Some mo -> 
			(* de meme *)
			let new_mo = item_add var item mo in
			(Some new_mo, etoile, fils)
		end
	    | c::q -> 
		begin
		  match fils with
		  | Nil -> 
		      let new_fils = CharMap.add c (aux empty q) CharMap.empty in
		      (complet, etoile, Tree new_fils)
		  | Tree tree ->
		      begin
			try
			  let current_fils = CharMap.find c tree in
			  let new_fils = CharMap.add c (aux current_fils q) tree in
			  (complet, etoile, Tree new_fils)
			with
			| Not_found ->
			    let new_fils = CharMap.add c (aux empty q) tree in
			    (complet, etoile, Tree new_fils)
		      end
		end
	  end 
    in aux tree char_list


  let map map_struct modul var value =
    let default = BoolArray.to_string value in
    let char_list = char_list_of_string modul in
    let map_map map = 
      try
	Item.map (StringMap.find var map) value
      with
      | Not_found -> default
    in
    let find_in_etoile last_etoile etoile =
     (*  prerr_endline "find in etoile"; *)
      begin
	match etoile with
	| Some map_item -> map_map map_item 
	| None ->
	    begin
	      (* On regarde si on a pas rencontrer d'etoile plus tot *)
	      match last_etoile with
	      | Some map_item -> map_map map_item
	      | None -> default
	    end
      end
    in
    let rec aux last_etoile tree rest =
      match tree with
      | (complet, etoile, fils) ->
	  begin
	    match rest with
	    | [] ->
		begin
		  (* On a tout lu, on essaye de trouver ici un complet *)
		  match complet with 
		  | Some map_item -> map_map map_item
		  | None -> find_in_etoile last_etoile etoile
		end
	    | c::q -> 

		(* prerr_endline (Printf.sprintf "Read '%c':" c); *)

		begin (* Il faut lire le caractere c *)
		  match fils with
		  | Nil -> find_in_etoile last_etoile etoile  
		  | Tree tree ->
		      (* On peut lire dans tree *)
		      begin
			try 
			  let sous_arbre = CharMap.find c tree in
			  (* Et eventuellement, rafraichir le prefixe pour prendre le plus long *)
			  match etoile with
			  | None -> aux last_etoile sous_arbre q 
			  | fresh -> aux fresh sous_arbre q
			with
			| Not_found -> find_in_etoile last_etoile etoile
		      end
		end
	  end 
    in aux None map_struct char_list



  let of_ast ast =
    (* On construit la table des definitions *)
    let defines = 
      let rec aux accu = function 
	| [] -> accu
	| (name, defs)::q ->
	    (
	      if StringMap.mem name accu 
	      then prerr_endline (Printf.sprintf "[!] mop-file : new definition of rule \"%s\"" name) 
	      else ()
	    );
	    let item = Item.make ~name:name defs in
	    aux (StringMap.add name item accu) q
      in aux StringMap.empty ast.defines
    in
    (* Et le final *)
    let add_var bloc accu = function
      | (var, UseDefine def) ->
	  begin
	    try
	      let item = StringMap.find def defines in
	      add bloc var item accu
	    with
	    | Not_found -> 
		prerr_endline (Printf.sprintf "[!] mop-file : definition of \"%s.%s\" ignored, rule \"%s\" Not Found" bloc var def);
		accu  
	  end 
      | (var, Anonymous matching) -> 
	  begin
	    let item = Item.make ~name:var matching in
	    try
	      add bloc var item accu
	    with
	    | Redefinition (b, v) -> 
		prerr_endline (Printf.sprintf "[!] mop-file : new definition of \"%s.%s\" ignored" b v);
		accu
	  end
    in
    let rec add_bloc accu = function
      | [] -> accu
      | (bloc_name, varmatch)::q -> 
	  let new_accu = List.fold_left (add_var bloc_name) accu varmatch in
	  add_bloc new_accu q
    in
    add_bloc empty ast.modules


  let of_file file = let ast = multi_parse file in of_ast ast

end 
  
  
(* Implementation du MapItem *)

module MapItem = 
struct
  type elt = (pattern * string * int list) * bool array 
	
  type t = elt list

  let repr ident t = Bplib.string_of_list Repr.elt ("\n"^(p_ident ident)) (p_ident ident) "" t
      
  (* Tester l'inclusion d'un partial dans un autre *)
  (* Si et seulement si tous les bits du premier sont inclus dans le deuxieme *)
  (* On considere qu'on appelle avec la meme taille *)
  let partial_subset p g =
    let len = Array.length p in 
    let rec aux i =
      if i < 0 then true
      else
	match p.(i), g.(i) with
	| _, None -> aux (pred i) (* on est toujours inclu dans l'etoile *) 
	| None, _ -> false (* un etoile generalise un bit, donc n'est pas inclue *)
	| Some a, Some b -> if a = b then aux (pred i) else false
    in aux (pred len)

  let make ~name list = 
    (* Cette partie est l'analyse statique d'une clause matching, a transformer *)
    (* Verification :
       - unification de taille
       - pointeurs ne debordent pas
       - toutes les branches sont used (priorite dans la definition)
       this match case is unused.
       Ceci est realise en verifiant au fur et a mesure qu'aucune nouvelle
       clause n'est inclue dans une precedente

       Optimisation : pointeur constant
    *)
    let matching_num = ref 1 in
    let max_matching = ref None in
    let size = ref None in
    let check_size s =
      match !size with
      | None -> size := Some s; max_matching := Some (BitReader.exp_int 2 s); true
      | Some u -> s = u
    in
    let unused_line line = prerr_endline (Printf.sprintf "[!] mop-file rule \"%s\" line %d : case %d is unused" name line (!matching_num)) in
    let unused_after_line line = prerr_endline (Printf.sprintf "[!] mop-file rule \"%s\" cases >= %d at line %d are unused" name (!matching_num) line)  in
    let out_bounds_pointeurs line = prerr_endline (Printf.sprintf "[!] mop-file rule \"%s\" line %d case %d : out of bounds, arg removed" name line (!matching_num))  in
    let size_unification line = prerr_endline (Printf.sprintf "[!] mop-file rule \"%s\" line %d case %d ignored due of size unification" name line (!matching_num))  in
    let format_error line message = prerr_endline (Printf.sprintf "[!] mop-file \"%s\" case %d line %d : format error \"%s\"" name (!matching_num) line message)  in
    let rec aux accu = function 
      | [] -> List.rev accu
      | (line, (Any, format, pointeurs))::q ->
	  begin
	    (
	      if q <> []
	      then unused_after_line line
	      else ()
	    );
	    (* Verification des pointeurs *)
	    let good_pointeurs, args =
	      match !size with
	      | None -> 
		  begin
		    (* il n'y en a pas, on va prendre le max des pointeurs *)
		    (* let max_p = List.fold_left Pervasives.max 0 pointeurs in *)
		    let args = Array.make (List.length pointeurs) false in
		    pointeurs, args 
		end
	      | Some len ->
		  begin
		    (* Verification des pointeurs *)
		    let args_length = ref 0 in
		    let good_pointeurs =
		      let first = ref true in
		      let filter i =
			if i < len && i >= 0
			then (incr(args_length); true)
			else (if !first then (first := false; out_bounds_pointeurs line; false) else false)
		      in List.filter filter pointeurs 
		    in
		    let args = Array.make (!args_length) false in
		    good_pointeurs, args
		  end
	    in
	    (* Test du format *)
	    let good_format =
	      try
		ignore (Display.sprintf format args);
		true
	      with
	      | Display.FormatError message -> format_error line message; false
	    in
	    if good_format
	    then (* Utilite du matching *)
	      if ( 
		match !max_matching with
		| None -> false
		| Some u -> u < !matching_num
	      )
	      then
		begin
		  unused_after_line line; 
		  List.rev accu
		end
	      else
		begin
		  incr(matching_num);
		  aux (((Any, format, good_pointeurs), args)::accu) []
		end
	    else aux accu []
	  end
      | (line, (Specified partial, format, pointeurs))::q ->
	  let len = Array.length partial in
	  if check_size len
	  then
	    begin
	      (* Verification des pointeurs *)
	      let tocst = ref [] in
	      let args_length = ref 0 in
	      let good_pointeurs =
		let first = ref true in
		let filter i =
		  if i < len && i >= 0
		  then 
		    begin
		      (* On verifie s'il n'est pas constant *)
		      match partial.(i) with
		      | Some cst -> 
			  begin
			    prerr_endline (Printf.sprintf "[!] mop-file line %d : cst '%c', arg %d removed" line (if cst then '1' else '0') i);
			    tocst := (!args_length, cst)::(!tocst);
			    incr(args_length);
			    true;
			  end
		      | None -> (incr(args_length); true)
		    end
		  else (if !first then (first := false; out_bounds_pointeurs line; false) else false)
		in List.filter filter pointeurs 
	      in
	      (* Test du format *)
	      let args = Array.make (!args_length) false in
	      List.iter (fun (i, v) -> args.(i) <- v) !tocst;
	      let good_format =
		try
		  ignore (Display.sprintf format args);
		  true
		with
		| Display.FormatError message -> format_error line message; false
	      in
	      if good_format 
	      then
		(* Test du unused *)
		if ( 
		  match !max_matching with
		  | None -> false
		  | Some u -> u < !matching_num
		)
		then
		  begin
		    if q <> [] then unused_after_line line else (); 
		    List.rev accu
		  end
		else
		if (List.exists (fun ((other, _, _), _) -> 
				   match other with Any -> true | Specified spec -> partial_subset partial spec) accu)
		then
		  begin
		    unused_line line;
		    aux accu q
		  end
		else
		  let new_matching = (Specified partial, format, good_pointeurs), args in
		  incr(matching_num);
		  aux (new_matching::accu) q
	      else aux accu q
	    end
	  else  
	    (
	      size_unification line;
	      aux accu q
	    )
    in aux [] list
  
  let map t value =
    let len_given = Array.length value in
    let default () = BoolArray.to_string value in
    (* On parcours la liste, et des qu'on trouve, on rend le maping *)
    let rec aux = function
      | [] -> default () 
      | ((Any, format, pointeurs), args)::_ ->
	  begin
	    let index = ref (-1) in
	    List.iter (fun i -> incr(index); if i < len_given then args.(!index) <- value.(i) else ()) pointeurs;
	    try
	      Display.sprintf format args
	    with Display.FormatError m -> 
	      prerr_endline (Printf.sprintf "Format Error : %s" m);
	      default () 
	  end

      | ((Specified partial, format, pointeurs), args)::q ->
	  begin
	    let len = Array.length partial in
	    if len_given <> len
	    then
	      begin
		prerr_endline (Printf.sprintf "[!] moping : expected value length %d" len);
		default () 
	      end
	    else
	    if PartialBoolArray.test_conflit partial value
	    then aux q
	    else (* On a un matching *)
	      begin
		let index = ref (-1) in
		List.iter (fun i -> incr(index); args.(!index) <- value.(i)) pointeurs;
		try
		  Display.sprintf format args
		with Display.FormatError m -> 
		  prerr_endline (Printf.sprintf "Format Error : %s" m);
		  default ()
	      end
	  end 
    in aux t
  
end 

module MapStruct = MapStructMake (MapItem) 


(* Maping d'une chaine au Format map *)
let map_format format value =
  let len = String.length format in
  let rec aux accu i =
    if i >= len then accu
    else
      if format.[i] = '%' || format.[i] = '@'
      then aux (accu^value) (succ i) 
      else aux (accu^(String.make 1 format.[i])) (succ i)
  in aux "" 0

